(load "F:\\class\\NLPLab\\workspace\\nlp-lab\\chart\\given-code.lisp")

;;----------------------------------------------------------------------
; gloval variables
(defvar *PARSE-VALUE*)

(defvar *entry-id*)
(defun get-id ()
  (setf *entry-id* (1+ *entry-id*))
  (1- *entry-id*))

(defvar *operation-counter*)
(defun operate ()
  (setf *operation-counter* (1+ *operation-counter*)))

(defun get-operation-count ()
  *operation-counter*)

(defun reset-counters ()
  (setf *entry-id* 1)
  (setf *operation-counter* 0))

;---------------------------------------
; tool methods

(defun is-root (ety final-position)
  (and (equal (entry-start ety) 1) (equal (entry-end ety) final-position)))

(defun add-to-list (lst item searchmode)
  (if (equal searchmode 'dfs)
      (cons item lst)
      (append lst (list item))))

(defun get-agenda-direction (searchmode)
  (if (equal searchmode 'dfs) 'top ' bottom))

(defun append-child (old-arc etr)
  (append (arc-children old-arc) (list (entry-id etr))))

;--------------------------------------
; generate arc

(defun get-arc (start end index lhs rhs children)
  (make-arc :start start :end end :index index :lhs lhs :rhs rhs :children children))

(defun get-arc-from-rule-entry (rl etr)
  (get-arc (entry-start etr) 
           (entry-end etr) 
           1 
           (rule-lhs rl)
           (rule-rhs rl)
           (list (entry-id etr))))

(defun get-arc-from-arc-entry (old-arc etr)
  (get-arc (arc-start old-arc) 
           (entry-end etr)
           (1+ (arc-index old-arc))
           (arc-lhs old-arc)
           (arc-rhs old-arc)
           (append-child old-arc etr)))

;--------------------------------------
; generate entry

(defun get-entry (start end category children lexeme)
  (make-entry :start start :end end :category category :children children :lexeme lexeme :id (get-id)))

(defun get-direct-entry (i xi ctgy)
  (get-entry i (1+ i) ctgy nil xi))

(defun get-completed-entry (old-arc etr)
  (get-entry (arc-start old-arc)
             (entry-end etr)
             (arc-lhs old-arc)
             (append-child old-arc etr)
             nil))

(defun get-direct-completed-entry (rl etr)
  (get-entry (entry-start etr)
             (entry-end etr)
             (rule-lhs rl)
             (list (entry-id etr))
             nil))

;-----------------------------------------------------------------------
; logical functions

(defun initialize-agenda (index xi searchmode)
  (let ((agenda nil))
    (dolist (ctgy (lookup-word xi))
      (let ((etr (get-direct-entry index xi ctgy)))
        
        (chart-trace "~% ~10a Entering ~a (~a from ~a to ~a) [agenda ~a]"
                     'EMPTY
                     (entry-category etr)
                     (entry-lexeme etr)
                     (entry-start etr)
                     (entry-end etr)
                     (get-agenda-direction searchmode))
        (operate)
        
        (setf agenda (add-to-list agenda etr searchmode))))
    agenda))

(defun add-direct-active-arcs (key active-arcs searchmode)
  (dolist (active-rule (rules-started-by (entry-category key)))
    (let ((active-arc (get-arc-from-rule-entry active-rule key)))
      
      (chart-trace "~% ~10a Starts rule ~a -> ~a from ~a to ~a"
                   key 
                   (arc-lhs active-arc) 
                   (insert-index (arc-index active-arc) (arc-rhs active-arc)) 
                   (arc-start active-arc) 
                   (arc-end active-arc))
      (operate)
      
      (setf active-arcs (add-to-list active-arcs active-arc searchmode))))
  active-arcs)

(defun add-direct-agenda (key agenda searchmode)
  (dolist (active-rule (rules-completed-by (entry-category key)))
    (let ((etr (get-direct-completed-entry active-rule key)))
      
      (chart-trace "~% ~10a Completes rule ~a -> ~a from ~a to ~a"
                   key
                   (rule-lhs active-rule)
                   (insert-index 1 (rule-rhs active-rule))
                   (entry-start etr)
                   (entry-end etr))
      (operate)
      
      (chart-trace "~% ~10a Entering ~a from ~a to ~a [agenda ~a]"
                   key
                   (entry-category etr)
                   (entry-start etr)
                   (entry-end etr)
                   (get-agenda-direction searchmode))
      (operate)
      
      (setf agenda (add-to-list agenda etr searchmode))))
  agenda)

(defun extend-active-arcs (key active-arcs searchmode)
  (dolist (active-arc (arcs-continued-by (entry-start key) (entry-category key) active-arcs))
    (let ((updated-arc (get-arc-from-arc-entry active-arc key)))
      
      (chart-trace "~% ~10a Continues arc ~a -> ~a from ~a to ~a"
                   key 
                   (arc-lhs updated-arc) 
                   (insert-index (arc-index updated-arc) (arc-rhs updated-arc)) 
                   (arc-start updated-arc) 
                   (arc-end updated-arc))
      (operate)
      
      (setf active-arcs (add-to-list active-arcs updated-arc searchmode))))
  active-arcs)

(defun extend-agenda (key active-arcs agenda searchmode)  (dolist (active-arc (arcs-completed-by (entry-start key) (entry-category key) active-arcs))
    (let ((etr (get-completed-entry active-arc key)))
      
      (chart-trace "~% ~10a Completes arc ~a -> ~a from ~a to ~a" key
                   (arc-lhs active-arc)
                   (insert-index (arc-index active-arc) (arc-rhs active-arc))
                   (arc-start active-arc) 
                   (arc-end active-arc))
      (operate)
      
      (chart-trace "~% ~10a Entering ~a from ~a to ~a [agenda ~a]"
                   key
                   (entry-category etr)
                   (entry-start etr) 
                   (entry-end etr) 
                   (get-agenda-direction searchmode))
      (operate)
      
      (setf agenda (add-to-list agenda etr searchmode))))
  agenda)

;;----------------------------------------------------------------------
;; BOTTOM-UP-CHART
;;
;; The top-level parser call.
;;
;; INPUT: a list of input symbols, which must be in *LEXICON*
;; GRAMMAR: a list of rule structures, such as *GRAMMAR*
;; SEARCHMODE: One of 'dfs (depth-first-search), 'bfs (breadth-first-search)
;; QUITMODE: if non-NIL, causes parser to quit as soon as it finds the
;;   first chart entry that covers the whole input.

(defun bottom-up-chart (input searchmode quitmode)
  (reset-counters)
  
  (let ((chart nil) (active-arcs nil) (key nil))
    
    (dotimes (i (length input))
      (let ((xi (nth i input)) (index (1+ i)) (agenda nil))
        
        (chart-trace "~% ~10a Reading from input ~a" 'EMPTY (subseq input i))
        (operate)
        
        ; find all POS of xi, and add them as constituents C(pi, pi+1) to the Agenda
        (setf agenda (initialize-agenda index xi searchmode))
        
        (do () ((null agenda))
          
          (setf key (pop agenda))
          
          ; pick and keyconstituent C(pj. pj+1) from the Agenda
          ; for each grammar rule of form A -> CX1 .. .Xm,
          ; add [A -> .CX1...Xm](pj, pj) to the list of active arcs.
          (setf active-arcs (add-direct-active-arcs key active-arcs searchmode))
          
          ; if the length is 1, this is used instead.
          (setf agenda (add-direct-agenda key agenda 'dfs))
          
          ; use key to extend all relevant active arcs.
          (setf active-arcs (extend-active-arcs key active-arcs searchmode))
          
          ; add lhs of any completed active arcs into the agenda.
          (setf agenda (extend-agenda key active-arcs agenda searchmode))
          
          ; insert the key into the chart, always from the top
          (setf chart (cons key chart))
          
          ; if key is S(1, n) then Accept the input, else go (2)
          (when (is-root key (1+ (length input)))
            (if quitmode
                (or (chart-trace "~% ~10a ** Covers the input, quitting [~a operations]"
                                 key (get-operation-count))
                    (and (operate) (return)))
                (chart-trace "~% ~10a ** Covers the input, continuing...[~a operations]"
                             key (get-operation-count)))
            (operate))
          )))
    
    (chart-trace "~% ~10a No input, quitting [~a operations]"
                 key (get-operation-count))
    (operate)
    
    (parse-trees (1+ (length input)) chart)
    
    (when *print-parse-tree* 
      (print-pretty-trees))
    
    chart))

;;----------------------------------------------------------------------

(defun print-pretty-trees ()
  (let ((i 1))
    (dolist (tree *parse-value*)
      (print (list 'parse '[ i ']))
      (pprint tree)
      (setf i (1+ i)))))

;;----------------------------------------------------------------------
;; PARSE-TREES
;;
;; Function to build trees for the nodes that cover the input.

(defun parse-trees (final-position chart)
  (setf *parse-value* nil)
  (dolist (chetr chart)
    (when (is-root chetr final-position)
      (setf *parse-value* (append *parse-value* (list (parse-tree chetr chart)))))))

;;----------------------------------------------------------------------
;; PARSE-TREE
;;
;; Function to create the tree structure for a single entry; recursive.

(defun parse-tree (entry chart)
  (let ((tree (list (entry-category entry))))
    (if (null (entry-children entry))
        (setf tree (append tree (list (entry-lexeme entry))))
        (dolist (sub-entry-id (entry-children entry))
          (dolist (chetr chart)
            (when (equal (entry-id chetr) sub-entry-id)
              (setf tree (append tree (list (parse-tree chetr chart))))))))
    tree))
